home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / skk / skk-kcode.el.z / skk-kcode.el
Encoding:
Text File  |  1998-05-21  |  16.4 KB  |  391 lines
  1. ;;; skk-kcode.el --- $B4A;z%3!<%I$r;H$C$?JQ49$N$?$a$N%W%m%0%i%`(B
  2. ;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997
  3. ;; Masahiko Sato <masahiko@kuis.kyoto-u.ac.jp>
  4.  
  5. ;; Author: Masahiko Sato <masahiko@kuis.kyoto-u.ac.jp>
  6. ;; Maintainer: Mikio Nakajima <minakaji@osaka.email.ne.jp>
  7. ;; Version: $Id: skk-kcode.el,v 1.3 1997/09/22 07:53:35 mrt Exp $
  8. ;; Keywords: japanese
  9. ;; Last Modified: $Date: 1997/09/22 07:53:35 $
  10.  
  11. ;; This program is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either versions 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; This program is distributed in the hope that it will be useful
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with SKK, see the file COPYING.  If not, write to the Free
  23. ;; Software Foundation Inc., 59 Temple Place - Suite 330, Boston,
  24. ;; MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; Following people contributed modifications to skk.el (Alphabetical order):
  29. ;;       Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
  30.  
  31. ;;; Code:
  32. (require 'skk-foreword)
  33. (require 'skk-vars)
  34.  
  35. (defvar skk-input-by-code-menu-keys1 '(?a ?s ?d ?f ?g ?h ?q ?w ?e ?r ?t ?y)
  36.   "*$B%a%K%e!<7A<0$G(B JIS $BJ8;z$rF~NO$9$k$H$-$K;HMQ$9$kA*Br%-!<$N%j%9%H!#(B
  37. $BBh(B 1 $BCJ3,$N%a%K%e!<$G;HMQ$9$k!#(B
  38. 12 $B8D$N%-!<(B (char type) $B$r4^$`I,MW$,$"$k!#(B")
  39.  
  40. (defvar skk-input-by-code-menu-keys2
  41.   '(?a ?s ?d ?f ?g ?h ?j ?k ?l ?q ?w ?e ?r ?t ?y ?u)
  42.   "*$B%a%K%e!<7A<0$G(B JIS $BJ8;z$rF~NO$9$k$H$-$K;HMQ$9$kA*Br%-!<$N%j%9%H!#(B
  43. $BBh(B 2 $BCJ3,$N%a%K%e!<$G;HMQ$9$k!#(B
  44. 16 $B8D$N%-!<(B (char type) $B$r4^$`I,MW$,$"$k!#(B")
  45.  
  46. (defvar skk-kcode-load-hook nil
  47.   "*skk-kcode.el $B$r%m!<%I$7$?8e$K%3!<%k$5$l$k%U%C%/!#(B" )
  48.  
  49. ;; variables for the function skk-input-by-code-or-menu
  50. (defconst skk-code-n1-min 161)
  51. (defconst skk-code-n1-max 244)
  52. (defconst skk-code-n2-min 161)
  53. (defconst skk-code-n2-max 254)
  54. (defconst skk-code-null 128)
  55. (defvar skk-input-by-code-or-menu-jump-default skk-code-n1-min)
  56. (skk-deflocalvar skk-kcode-charset
  57.   (if (or skk-mule3 skk-xemacs)
  58.       'japanese-jisx0208
  59.     lc-jp)
  60.   "skk-input-by-code-or-menu $B$G;H$o$l$kJ8;z%;%C%H!#(B" )
  61. (defconst skk-kcode-definded-charsets
  62.   (if (or skk-mule3 skk-xemacs)
  63.       (mapcar '(lambda (x) (list (symbol-name x))) (charset-list))
  64.     nil ))
  65.  
  66. ;;;###skk-autoload
  67. (defun skk-input-by-code-or-menu (&optional arg)
  68.   "7bit $B$b$7$/$O(B 8bit $B$b$7$/$O(B $B6hE@%3!<%I$KBP1~$9$k(B 2byte $BJ8;z$rA^F~$9$k!#(B"
  69.   ;; The function skk-input-by-code-or-menu, which was used until version
  70.   ;; 4.20, is now replaced by this new function.
  71.   (interactive "*P")
  72.   (if arg
  73.       (let ((charset
  74.          (intern (completing-read (format "CHARSET(%s): " skk-kcode-charset)
  75.                       skk-kcode-definded-charsets nil t ))))
  76.     (cond ((null charset))
  77.           ((not (skk-charsetp charset))
  78.            (error "invalid charset"))
  79.           (t (setq skk-kcode-charset charset)) )))
  80.   (let ((str
  81.      (read-string
  82.       (format
  83.        "7/8 bits or KUTEN code for %s (00nn or CR for Jump Menu): "
  84.        skk-kcode-charset )))
  85.     (enable-recursive-mini-buffer t)
  86.     n1 n2 )
  87.     (if (string-match "\\(.+\\)-\\(.+\\)" str)
  88.     (setq n1 (+ (string-to-number (match-string 1 str)) 32 128)
  89.           n2 (+ (string-to-number (match-string 2 str)) 32 128) )
  90.       (setq n1 (if (string= str "") 128
  91.          (+ (* 16 (skk-jis-char-to-hex (aref str 0)))
  92.             (skk-char-to-hex (aref str 1)) ))
  93.         n2 (if (string= str "") 128
  94.          (+ (* 16 (skk-jis-char-to-hex (aref str 2)))
  95.             (skk-char-to-hex (aref str 3)) ))))
  96.     (insert (if (> n1 160)
  97.         (skk-make-string n1 n2)
  98.           (skk-input-by-code-or-menu-0 n1 n2) ))
  99.     (if skk-henkan-active (skk-kakutei)) ))
  100.  
  101. (defun skk-char-to-hex (char)
  102.   (cond ((> char 96) (- char 87)) ; a-f
  103.         ((> char 64) (- char 55)) ; A-F
  104.         ((> char 47) (- char 48)) ; 0-9
  105.         (t
  106.          ;; $BJ*8@$o$L%(%i!<$ONI$/$J$$$,(B...$B!#(B
  107.          (error "") )))
  108.  
  109. (defun skk-jis-char-to-hex (char)
  110.   (cond ((> char 96) (- char 87)) ; a-f
  111.         ((> char 64) (- char 55)) ; A-F
  112.         ((> char 47) (- char 40)) ; 0-9
  113.         (t
  114.          ;; $BJ*8@$o$L%(%i!<$ONI$/$J$$$,(B...$B!#(B
  115.          (error "") )))
  116.  
  117. (defun skk-make-string (n1 n2)
  118.   (char-to-string (skk-make-char skk-kcode-charset n1 n2)) )
  119.  
  120. (defun skk-next-n2-code (n)
  121.   (if (<= (setq n (1+ n)) skk-code-n2-max) n skk-code-n2-min))
  122.  
  123. (defun skk-previous-n2-code (n)
  124.   (if (<= skk-code-n2-min (setq n (1- n))) n skk-code-n2-max))
  125.  
  126. (defun skk-next-n1-code (n)
  127.   (if (<= (setq n (1+ n)) skk-code-n1-max) n skk-code-n1-min))
  128.  
  129. (defun skk-previous-n1-code (n)
  130.   (if (<= skk-code-n1-min (setq n (1- n))) n skk-code-n1-max))
  131.  
  132. (defun skk-input-by-code-or-menu-0 (n1 n2)
  133.   (if (= n1 skk-code-null)
  134.       (skk-input-by-code-or-menu-jump n2)
  135.     (skk-input-by-code-or-menu-1 n1 n2)))
  136.  
  137. (defun skk-input-by-code-or-menu-jump (n)
  138.   (let ((menu-keys1 ; $BI=<(MQ$N%-!<%j%9%H$rAH$_N)$F$k!#(B
  139.          (mapcar (function (lambda (char) (char-to-string (upcase char))))
  140.                  skk-input-by-code-menu-keys1 ))
  141.         kanji-char )
  142.     (if (< n skk-code-n1-min) (setq n skk-input-by-code-or-menu-jump-default))
  143.     (while (not kanji-char)
  144.       (let ((n-org n)
  145.             (chars
  146.              (list
  147.               (list (skk-make-string n skk-code-n1-min) n skk-code-n1-min)
  148.               (list (skk-make-string n 177) n 177)
  149.               (list (skk-make-string n 193) n 193)
  150.               (list (skk-make-string n 209) n 209)
  151.               (list (skk-make-string n 225) n 225)
  152.               (list (skk-make-string n 241) n 241)
  153.               (progn
  154.                 (setq n (skk-next-n1-code n))
  155.                 (list (skk-make-string n skk-code-n1-min) n
  156.                       skk-code-n1-min ))
  157.               (list (skk-make-string n 177) n 177)
  158.               (list (skk-make-string n 193) n 193)
  159.               (list (skk-make-string n 209) n 209)
  160.               (list (skk-make-string n 225) n 225)
  161.               (list (skk-make-string n 241) n 241))))
  162.         (skk-save-point
  163.           (let ((i 0) message-log-max str )
  164.             (while (< i 12)
  165.               (setq str (concat str (nth i menu-keys1) ":" (car (nth i chars))
  166.                                 "  " ))
  167.               (setq i (1+ i)) )
  168.             (message str) )
  169.           (let ((char (skk-read-event))
  170.                 rest ch )
  171.             (if (not (integerp char))
  172.                 (progn
  173.                   (skk-message "\"%s\" $B$OM-8z$J%-!<$G$O$"$j$^$;$s!*(B"
  174.                                "\"%s\" is not valid here!" (prin1 char) )
  175.                   (sit-for 1)
  176.                   (message "")
  177.                   (setq n n-org) )
  178.               (setq rest (or (memq char skk-input-by-code-menu-keys1)
  179.                              (if (skk-lower-case-p char)
  180.                                  (memq (upcase char) skk-input-by-code-menu-keys1)
  181.                                (memq (downcase char) skk-input-by-code-menu-keys1) ))
  182.                     ch (if rest
  183.                            ;; 12 == (length skk-input-by-code-menu-keys1)
  184.                            (nth (- 12 (length rest)) chars)
  185.                          nil )
  186.                     kanji-char
  187.                     (cond
  188.                      (ch)
  189.                      ((eq char 120)     ; x
  190.                       (if (< (setq n (- n-org 2)) skk-code-n1-min)
  191.                           (setq n skk-code-n1-max))
  192.                       nil)
  193.                      ((eq char 32)      ; space
  194.                       (setq n (skk-next-n1-code n))
  195.                       nil)
  196.                      ((eq char 63)      ; ?
  197.                       (skk-message
  198.                        (concat "$B!X(B%s$B!Y(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d)  "
  199.                                "[$B2?$+%-!<$r2!$7$F$/$@$5$$(B]" )
  200.                        (concat "$B!X(B%s$B!Y(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d)  "
  201.                                "[Hit any key to continue]" )
  202.                        (car (car chars))
  203.                        n-org skk-code-n1-min n-org skk-code-n1-min
  204.                        (- n-org 128) (- skk-code-n1-min 128)
  205.                        (- n-org 128) (- skk-code-n1-min 128) )
  206.                       (skk-read-event)
  207.                       (setq n n-org)
  208.                       nil)
  209.                      (t
  210.                       (skk-message "\"%c\" $B$OM-8z$J%-!<$G$O$"$j$^$;$s!*(B"
  211.                                    "\"%c\" is not valid here!" char )
  212.                       (sit-for 1)
  213.                       (message "")
  214.                       (setq n n-org)
  215.                       nil ))))))))
  216.     (setq skk-input-by-code-or-menu-jump-default (car (cdr kanji-char)))
  217.     (skk-input-by-code-or-menu-1
  218.      (car (cdr kanji-char)) (car (cdr (cdr kanji-char))) )))
  219.  
  220. (defun skk-input-by-code-or-menu-1 (n1 n2)
  221.   (let ((menu-keys2 ; $BI=<(MQ$N%-!<%j%9%H$rAH$_N)$F$k!#(B
  222.          (mapcar (function (lambda (char) (char-to-string (upcase char))))
  223.                  skk-input-by-code-menu-keys2 ))
  224.         kanji-char )
  225.     (while (not kanji-char)
  226.       (let ((n1-org n1) (n2-org n2) (i 0)
  227.             (chars (list (skk-make-string n1 n2))))
  228.         ;; 16 == (length skk-input-by-code-menu-keys2)
  229.         (while (< i 16)
  230.           (nconc chars (list
  231.                         (progn (setq n2 (skk-next-n2-code n2))
  232.                                (if (= n2 skk-code-n2-min)
  233.                                    (setq n1 (skk-next-n1-code n1)))
  234.                                (skk-make-string n1 n2))))
  235.           (setq i (1+ i)))
  236.         (skk-save-point
  237.           (let ((i 0) message-log-max str )
  238.             (while (< i 16)
  239.               (setq str (concat str (nth i menu-keys2) ":" (nth i chars) " "))
  240.               (setq i (1+ i)) )
  241.             (message str) )
  242.           (let ((char (skk-read-event)))
  243.             (if (not (integerp char))
  244.                 (progn
  245.                   (skk-message "\"%s\" $B$OM-8z$J%-!<$G$O$"$j$^$;$s!*(B"
  246.                                "\"%s\" is not valid here!" (prin1 char) )
  247.                   (sit-for 1)
  248.                   (message "")
  249.                   (setq n1 n1-org n2 n2-org) )
  250.               (setq rest
  251.                     (or (memq char skk-input-by-code-menu-keys2)
  252.                         (if (skk-lower-case-p char)
  253.                             (memq (upcase char) skk-input-by-code-menu-keys2)
  254.                           (memq (downcase char) skk-input-by-code-menu-keys2) ))
  255.                     ch (if rest
  256.                            ;; 16 == (length skk-input-by-code-menu-keys2)
  257.                            (nth (- 16 (length rest)) chars) )
  258.                     kanji-char
  259.                     (cond
  260.                      (ch)
  261.                      ((eq char 120)     ; x
  262.                       (if (< (setq n2 (- n2 31)) skk-code-n2-min)
  263.                           (setq n2 (+ n2 94)
  264.                                 n1 (skk-previous-n1-code n1)))
  265.                       nil )
  266.                      ((eq char 32)      ; space
  267.                       (if (= (setq n2 (skk-next-n2-code n2))
  268.                              skk-code-n2-min)
  269.                           (setq n1 (skk-next-n1-code n1)))
  270.                       nil )
  271.                      ((eq char 63)      ; ?
  272.                       (skk-message
  273.                        (concat "$B!X(B%s$B!Y(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d)  "
  274.                                "[$B2?$+%-!<$r2!$7$F$/$@$5$$(B]" )
  275.                        (concat "$B!X(B%s$B!Y(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d)  "
  276.                                "[Hit any key to continue]" )
  277.                        (car chars) n1-org n2-org n1-org n2-org
  278.                        (- n1-org 128) (- n2-org 128)
  279.                        (- n1-org 128) (- n2-org 128) )
  280.                       (skk-read-event)
  281.                       (setq n1 n1-org n2 n2-org)
  282.                       nil )
  283.                      ((eq char 62)      ; >
  284.                       (if (= (setq n2 (skk-next-n2-code n2-org))
  285.                              skk-code-n2-min)
  286.                           (setq n1 (skk-next-n1-code n1-org))
  287.                         (setq n1 n1-org))
  288.                       nil )
  289.                      ((eq char 60)      ; <
  290.                       (if (= (setq n2 (skk-previous-n2-code n2-org))
  291.                              skk-code-n2-max)
  292.                           (setq n1 (skk-previous-n1-code n1-org))
  293.                         (setq n1 n1-org))
  294.                       nil )
  295.                      (t
  296.                       (skk-message "\"%c\" $B$OM-8z$J%-!<$G$O$"$j$^$;$s!*(B"
  297.                                    "\"%c\" is not valid here!" char )
  298.                       (sit-for 1)
  299.                       (message "")
  300.                       (setq n1 n1-org n2 n2-org)
  301.                       nil ))))))))
  302.     kanji-char ))
  303.  
  304. ;;;###skk-autoload
  305. (defun skk-display-code-for-char-at-point ()
  306.   "$B%]%$%s%H$K$"$kJ8;z$N(B EUC $B%3!<%I$H(B JIS $B%3!<%I$rI=<($9$k!#(B"
  307.   (interactive)
  308.   (if (eobp)
  309.       (skk-error "$B%+!<%=%k$,%P%C%U%!$N=*C<$K$"$j$^$9(B"
  310.                  "Cursor is at the end of the buffer" )
  311.     (let ((str
  312.            (skk-buffer-substring
  313.             (point)
  314.             (skk-save-point (forward-char 1) (point)))))
  315.       (cond
  316.        (skk-xemacs
  317.         (let* ((char (string-to-char str))
  318.                (charset (char-charset char)))
  319.           (cond
  320.            ((memq charset '(japanese-jisx0208 japanese-jisx0208-1978))
  321.             (let* ((char1-j (char-octet char 0))
  322.                    (char1-k (- char1-j 32))
  323.                    (char1-e (+ char1-j 128))
  324.                    (char2-j (char-octet char 1))
  325.                    (char2-k (- char2-j 32))
  326.                    (char2-e (+ char2-j 128)))
  327.               (message
  328.                "$B!X(B%s$B!Y(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d), KUTEN: (%2d, %2d)"
  329.                str char1-e char2-e char1-e char2-e
  330.                char1-j char2-j char1-j char2-j char1-k char2-k)))
  331.            ((memq charset '(ascii latin-jisx0201))
  332.             (message "\"%s\"  %2x (%3d)"
  333.                      str (char-octet char 0)  (char-octet char 0)))
  334.            (t
  335.             (skk-error "$BH=JL$G$-$J$$J8;z$G$9(B"
  336.                        "Cannot understand this character")))
  337.           ))
  338.        (skk-mule3
  339.         (let* ((char (string-to-char str))
  340.                (charset (char-charset char)))
  341.           (cond
  342.            ((memq charset '(japanese-jisx0208 japanese-jisx0208-1978))
  343.             (let* ((char-list (mapcar (function +) str))
  344.                    (char1-e (car (cdr char-list)))
  345.                    (char1-j (- char1-e 128))
  346.                    (char1-k (- char1-j 32))
  347.                    (char2-e (car (cdr (cdr char-list))))
  348.                    (char2-j (- char2-e 128))
  349.                    (char2-k (- char2-j 32)))
  350.               (message
  351.                "$B!X(B%s$B!Y(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d), KUTEN: (%2d, %2d)"
  352.                str char1-e char2-e char1-e char2-e
  353.                char1-j char2-j char1-j char2-j char1-k char2-k)))
  354.            ((memq charset '(ascii latin-jisx0201))
  355.             (message "\"%s\"  %2x (%3d)" char char char))
  356.            (t
  357.             (skk-error "$BH=JL$G$-$J$$J8;z$G$9(B"
  358.                        "Cannot understand this character")))
  359.           ))
  360.        (t ; skk-mule
  361.         (let (;; $BJ8;zNs$r(B char $B$KJ,2r!#(B
  362.               ;; (mapcar '+ str) == (append str nil)
  363.               (char-list (mapcar (function +) str)))
  364.           (cond
  365.            ((and (= (length char-list) 3)
  366.                  (memq (car char-list) (list lc-jp lc-jpold)))
  367.             (let* ((char1-e (car (cdr char-list)))
  368.                    (char1-j (- char1-e 128))
  369.                    (char1-k (- char1-j 32))
  370.                    (char2-e (car (cdr (cdr char-list))))
  371.                    (char2-j (- char2-e 128))
  372.                    (char2-k (- char2-j 32)))
  373.               (message
  374.                "$B!X(B%s$B!Y(B  EUC: %2x%2x (%3d, %3d), JIS: %2x%2x (%3d, %3d), KUTEN: (%2d, %2d)"
  375.                str char1-e char2-e char1-e char2-e
  376.                char1-j char2-j char1-j char2-j char1-k char2-k)))
  377.            ((or (= (length char-list) 1) ; ascii character
  378.                 (memq (car char-list) (list lc-ascii lc-roman)))
  379.             (let ((char (car char-list)))
  380.               (message "\"%c\"  %2x (%3d)" char char char)))
  381.            (t
  382.             (skk-error "$BH=JL$G$-$J$$J8;z$G$9(B"
  383.                        "Cannot understand this character" ))
  384.            )))
  385.        ))))
  386.  
  387. (run-hooks 'skk-kcode-load-hook)
  388.  
  389. (provide 'skk-kcode)
  390. ;;; skk-kcode.el ends here
  391.